perm filename HIDE[900,BGB] blob
sn#129592 filedate 1974-11-11 generic text, type T, neo UTF8
(SETQ IBASE (ADD1 7))
(DEFPROP ALL
(NIL MAPPENDCAR
INTER
UNRES
MMMM
POINT-AND-ODD-VERTEX-IN-SAME-HALF-PLANE?
CORNER-WITHIN-TRIANGLE?
MAPPENDLIST
LISTASSOC
DELETE
GREATERPEQ
CORNER-WITHIN-ANY-TRIANGLE?
SPLIT-POLYGON-INTO-TRIANGLES
MIDPOINT
CHEAP-SPLICE
ENDPOINTS-BEYOND-WINDOW?
ENDPOINTS-WITHIN-WINDOW?
IS-EACH-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?
IS-WINDOW-SURROUNDED-BY-CIRCUMSCRIBED-RECTANGLE?
*LEAST
*MOST
LEAST
MOST
DETMAT
SAMEPOINT?
CLIP-LINE-SEGMENT
XXXXXX
NIL-BEYOND-DEPTH-BOUND
SURROUNDS-WINDOW?
ZDEPTH
EXTREMA
CLIP2
ENDPOINTS
SET-INTERSECTION
KRAMER
SPLICE2
SPLICE1
ONCEONLY
ORDLOW
UNRESOLVED
SMALL?
SIMPLE?
TRIVAIL
CLIP
ABOVE
HIDE-POLY
SURROUND
DIW-PROPERTY
MAPORCAR
IS-ANY-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?
WINDOW-IN-OPPOSITE-HALF-PLANE?
OUTSIDE
TWO-INTERSECTING-PLANES?
FORM-NEW-EDGE
TWO-POLY-WITH-COMMON-EDGE
ENDS-PROPERTY
INITIALIZE-CIRCUMSCRIBED-RECTANGLE-PROPERTY
INITIALIZE-PLANE-OF-POLYGON-PROPERTIES
SUPERSPLICE2
SUPERSPLICE1
WARNOCK
INITPOLY
HIDDEN-LINE)
VALUE)
(DEFPROP MAPPENDCAR
(LAMBDA (FN L) (COND ((NULL L) NIL) (T (APPEND (FN (CAR L)) (MAPPENDCAR FN (CDR L))))))
EXPR)
(DEFPROP INTER
(NIL)
VALUE)
(DEFPROP UNRES
(NIL)
VALUE)
(DEFPROP MMMM
(LAMBDA(X Y Z)
(DIFFERENCE (TIMES (DIFFERENCE (CADAR Z) Y 0.0) (DIFFERENCE (CAAR Z) (CAADR Z)))
(TIMES (DIFFERENCE (CAAR Z) X 0.0) (DIFFERENCE (CADAR Z) (CADADR Z)))))
EXPR)
(DEFPROP POINT-AND-ODD-VERTEX-IN-SAME-HALF-PLANE?
(LAMBDA(TRIANGLE)
(NOT (MINUSP (TIMES (MMMM X Y (CDR TRIANGLE)) (MMMM (CAAR TRIANGLE) (CADAR TRIANGLE) (CDR TRIANGLE))))))
EXPR)
(DEFPROP CORNER-WITHIN-TRIANGLE?
(LAMBDA(TRIANGLE)
(AND (POINT-AND-ODD-VERTEX-IN-SAME-HALF-PLANE? TRIANGLE)
(POINT-AND-ODD-VERTEX-IN-SAME-HALF-PLANE? (REVERSE TRIANGLE))
(POINT-AND-ODD-VERTEX-IN-SAME-HALF-PLANE? (APPEND (CDR TRIANGLE) (NCONS (CAR TRIANGLE))))))
EXPR)
(DEFPROP MAPPENDLIST
(LAMBDA (FN L) (COND ((NULL L) NIL) (T (APPEND (FN L) (MAPPENDLIST FN (CDR L))))))
EXPR)
(DEFPROP LISTASSOC
(LAMBDA (Z) (MAPPENDCAR (FUNCTION (LAMBDA (A) (LIST (CAAR A) A))) Z))
EXPR)
(DEFPROP DELETE
(LAMBDA(A Z)
(COND ((NULL Z) NIL) (T (APPEND (COND ((EQ A (CAR Z)) NIL) (T (NCONS (CAR Z)))) (DELETE A (CDR Z))))))
EXPR)
(DEFPROP GREATERPEQ
(LAMBDA (A B C) (OR (GREATERP A B C) (EQUAL A B) (EQUAL B C)))
EXPR)
(DEFPROP CORNER-WITHIN-ANY-TRIANGLE?
(LAMBDA(TRIANGLE-LIST X Y)
(COND ((NULL TRIANGLE-LIST) NIL)
((CORNER-WITHIN-TRIANGLE? (CAR TRIANGLE-LIST)) T)
(T (CORNER-WITHIN-ANY-TRIANGLE? (CDR TRIANGLE-LIST) X Y))))
EXPR)
(DEFPROP SPLIT-POLYGON-INTO-TRIANGLES
(LAMBDA NIL
(SETQ TRIANGLE-LIST
(MAPPENDLIST (FUNCTION
(LAMBDA(LIST-OF-CORNERS)
(COND ((GREATERP 3 (LENGTH LIST-OF-CORNERS)) NIL)
(T
(NCONS
(CONS (CAR LIST-OF-CORNERS)
(CONS (CADR LIST-OF-CORNERS) (LAST LIST-OF-CORNERS))))))))
(MAPCAR (FUNCTION (LAMBDA (CORNER) (GET CORNER (QUOTE IMAGE))))
(GET POLYGON (QUOTE CORNERS))))))
EXPR)
(DEFPROP MIDPOINT
(LAMBDA (LINE) (CONS (QUOTIENT (PLUS (CAAR LINE) (CADR LINE)) 2) (QUOTIENT (PLUS (CDAR LINE) (CDDR LINE)) 2)))
EXPR)
(DEFPROP CHEAP-SPLICE
(LAMBDA (A B) (COND ((NULL A) B) ((NULL B) A) (T (CONS (CAR A) (CDR B)))))
EXPR)
(DEFPROP ENDPOINTS-BEYOND-WINDOW?
(LAMBDA NIL
(OR (AND (GREATERP (CAAR LINE) XHIGH) (GREATERP (CADR LINE) XHIGH))
(AND (GREATERP (CDAR LINE) YHIGH) (GREATERP (CDDR LINE) YHIGH))
(AND (LESSP (CAAR LINE) XLOW) (LESSP (CADR LINE) XLOW))
(AND (LESSP (CDAR LINE) YLOW) (LESSP (CDDR LINE) YLOW))))
EXPR)
(DEFPROP ENDPOINTS-WITHIN-WINDOW?
(LAMBDA NIL
(AND (GREATERPEQ XHIGH (CAAR LINE) XLOW)
(GREATERPEQ XHIGH (CADR LINE) XLOW)
(GREATERPEQ YHIGH (CDAR LINE) YLOW)
(GREATERPEQ YHIGH (CDDR LINE) YLOW)))
EXPR)
(DEFPROP IS-EACH-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?
(LAMBDA NIL
(PROG (TRIANGLE-LIST)
(SPLIT-POLYGON-INTO-TRIANGLES)
(RETURN
(AND (CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XLOW YLOW)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XLOW YHIGH)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XHIGH YLOW)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XHIGH YHIGH)))))
EXPR)
(DEFPROP IS-WINDOW-SURROUNDED-BY-CIRCUMSCRIBED-RECTANGLE?
(LAMBDA NIL
(AND (GREATERP (GET POLYGON (QUOTE XHIGH)) XHIGH)
(GREATERP (GET POLYGON (QUOTE YHIGH)) YHIGH)
(LESSP (GET POLYGON (QUOTE XLOW)) XLOW)
(LESSP (GET POLYGON (QUOTE YLOW)) YLOW)))
EXPR)
(DEFPROP *LEAST
(LAMBDA (MIN Z) (COND ((NULL Z) MIN) ((LESSP (CAR Z) MIN) (*LEAST (CAR Z) (CDR Z))) (T (*LEAST MIN (CDR Z)))))
EXPR)
(DEFPROP *MOST
(LAMBDA(MAX Z)
(COND ((NULL Z) MAX) ((GREATERP (CAR Z) MAX) (*MOST (CAR Z) (CDR Z))) (T (*MOST MAX (CDR Z)))))
EXPR)
(DEFPROP LEAST
(LAMBDA (Z) (*LEAST 77777777777 Z))
EXPR)
(DEFPROP MOST
(LAMBDA (Z) (*MOST -77777777777 Z))
EXPR)
(DEFPROP DETMAT
(LAMBDA(D E F)
(PLUS (TIMES (CAR D) (DIFFERENCE (TIMES (CADR E) (CADDR F)) (TIMES (CADR F) (CADDR E)) 0.0))
(TIMES (MINUS (CAR E)) (DIFFERENCE (TIMES (CADR D) (CADDR F)) (TIMES (CADR F) (CADDR D))))
(TIMES (CAR F) (DIFFERENCE (TIMES (CADR D) (CADDR E)) (TIMES (CADR E) (CADDR D))))))
EXPR)
(DEFPROP SAMEPOINT?
(LAMBDA(A B)
(AND (GREATERP 1.0 (ABS (DIFFERENCE (CAR A) (CAR B)))) (GREATERP 1.0 (ABS (DIFFERENCE (CDR A) (CDR B))))))
EXPR)
(DEFPROP CLIP-LINE-SEGMENT
(LAMBDA(LINE)
(COND ((ENDPOINTS-WITHIN-WINDOW?) LINE)
((ENDPOINTS-BEYOND-WINDOW?) NIL)
((SAMEPOINT? (CAR LINE) (CDR LINE)) NIL)
(T
(CHEAP-SPLICE (CLIP-LINE-SEGMENT (CONS (CAR LINE) (MIDPOINT LINE)))
(CLIP-LINE-SEGMENT (CONS (MIDPOINT LINE) (CDR LINE)))))))
EXPR)
(DEFPROP XXXXXX
(LAMBDA (A B) (COND ((NULL A) B) (T (CONS A B))))
EXPR)
(DEFPROP NIL-BEYOND-DEPTH-BOUND
(LAMBDA (POLYGON) (COND ((LESSP DEPTH-BOUND (CAR (GET POLYGON (QUOTE DIW)))) NIL) (T (NCONS POLYGON))))
EXPR)
(DEFPROP SURROUNDS-WINDOW?
(LAMBDA(POLYGON)
(AND (IS-WINDOW-SURROUNDED-BY-CIRCUMSCRIBED-RECTANGLE?) (IS-EACH-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?)))
EXPR)
(DEFPROP ZDEPTH
(LAMBDA(X Y)
(QUOTIENT (DIFFERENCE 100.0 (TIMES (GET POLYGON (QUOTE A)) X) (TIMES (GET POLYGON (QUOTE B)) Y))
(GET POLYGON (QUOTE C))))
EXPR)
(DEFPROP EXTREMA
(LAMBDA (LIST-OF-NUMBERS) (CONS (LEAST LIST-OF-NUMBERS) (MOST LIST-OF-NUMBERS)))
EXPR)
(DEFPROP CLIP2
(LAMBDA NIL
(MAPC (FUNCTION
(LAMBDA(EDGE)
(PUTPROP EDGE (XXXXXX (CLIP-LINE-SEGMENT (GET EDGE (QUOTE ENDS))) (GET EDGE VIEWNAME)) VIEWNAME)))
(GET (CAR POLYGON-LIST) (QUOTE EDGEZ))))
EXPR)
(DEFPROP ENDPOINTS
(LAMBDA(POLY1 POLY2)
(PROG (M B K)
(SETQ M
(DIFFERENCE (QUOTIENT (GET POLY1 (QUOTE A)) (GET POLY1 (QUOTE C)))
(QUOTIENT (GET POLY2 (QUOTE A)) (GET POLY2 (QUOTE C)))))
(SETQ B
(DIFFERENCE (QUOTIENT (GET POLY1 (QUOTE B)) (GET POLY1 (QUOTE C)))
(QUOTIENT (GET POLY2 (QUOTE B)) (GET POLY2 (QUOTE C)))))
(SETQ K (DIFFERENCE (QUOTIENT 100.0 (GET POLY1 (QUOTE C))) (QUOTIENT 100.0 (GET POLY2 (QUOTE C)))))
(COND ((GREATERP (ABS M) (ABS B))
(RETURN
(CONS (CONS (QUOTIENT (DIFFERENCE K (TIMES B 511.0)) M) 511.0)
(CONS (QUOTIENT (DIFFERENCE K (TIMES B -511.0)) M) -511.0))))
(T
(RETURN
(CONS (CONS 511.0 (QUOTIENT (DIFFERENCE K (TIMES M 511.0)) B))
(CONS -511.0 (QUOTIENT (DIFFERENCE K (TIMES M -511.0)) B))))))))
EXPR)
(DEFPROP SET-INTERSECTION
(LAMBDA(A B)
(PROG (Z1 Z2)
(SETQ Z1 A)
(SETQ Z2 NIL)
L (COND ((NULL Z1) (RETURN Z2)))
(COND ((MEMBER (CAR Z1) B) (SETQ Z2 (CONS (CAR Z1) Z2))))
(SETQ Z1 (CDR Z1))
(GO L)))
EXPR)
(DEFPROP KRAMER
(LAMBDA(A B C)
(PROG (XS YS ZS DENOM KVEC)
(SETQ XS (LIST (CAR A) (CAR B) (CAR C)))
(SETQ YS (LIST (CADR A) (CADR B) (CADR C)))
(SETQ ZS (LIST (CADDR A) (CADDR B) (CADDR C)))
(SETQ DENOM (DETMAT XS YS ZS))
(SETQ KVEC (LIST 100.0 100.0 100.0))
(RETURN
(LIST (QUOTIENT (DETMAT KVEC YS ZS) DENOM)
(QUOTIENT (DETMAT XS KVEC ZS) DENOM)
(QUOTIENT (DETMAT XS YS KVEC) DENOM)))))
EXPR)
(DEFPROP SPLICE2
(LAMBDA(LINE LINE-LIST)
(COND ((NULL LINE) LINE-LIST)
((NULL LINE-LIST) (LIST LINE))
((EQUAL (CAR LINE) (CAAR LINE-LIST)) (SPLICE2 (CONS (CDR LINE) (CDAR LINE-LIST)) (CDR LINE-LIST)))
((EQUAL (CAR LINE) (CDAR LINE-LIST)) (SPLICE2 (CONS (CDR LINE) (CAAR LINE-LIST)) (CDR LINE-LIST)))
((EQUAL (CDR LINE) (CAAR LINE-LIST)) (SPLICE2 (CONS (CAR LINE) (CDAR LINE-LIST)) (CDR LINE-LIST)))
((EQUAL (CDR LINE) (CDAR LINE-LIST)) (SPLICE2 (CONS (CAR LINE) (CAAR LINE-LIST)) (CDR LINE-LIST)))
(T (CONS (CAR LINE-LIST) (SPLICE2 LINE (CDR LINE-LIST))))))
EXPR)
(DEFPROP SPLICE1
(LAMBDA(LINE LINE-LIST)
(COND ((NULL LINE) LINE-LIST)
((NULL LINE-LIST) (LIST LINE))
((SAMEPOINT? (CAR LINE) (CAAR LINE-LIST)) (SPLICE1 (CONS (CDR LINE) (CDAR LINE-LIST)) (CDR LINE-LIST)))
((SAMEPOINT? (CAR LINE) (CDAR LINE-LIST)) (SPLICE1 (CONS (CDR LINE) (CAAR LINE-LIST)) (CDR LINE-LIST)))
((SAMEPOINT? (CDR LINE) (CAAR LINE-LIST)) (SPLICE1 (CONS (CAR LINE) (CDAR LINE-LIST)) (CDR LINE-LIST)))
((SAMEPOINT? (CDR LINE) (CDAR LINE-LIST)) (SPLICE1 (CONS (CAR LINE) (CAAR LINE-LIST)) (CDR LINE-LIST)))
(T (CONS (CAR LINE-LIST) (SPLICE1 LINE (CDR LINE-LIST))))))
EXPR)
(DEFPROP ONCEONLY
(LAMBDA(Z)
(PROG (A B)
(SETQ A Z)
(SETQ B NIL)
L (COND ((NULL A) (RETURN (REVERSE B))))
(COND ((NOT (MEMBER (CAR A) (CDR A))) (SETQ B (CONS (CAR A) B))))
(SETQ A (CDR A))
(GO L)))
EXPR)
(DEFPROP ORDLOW
(LAMBDA (Z) (COND ((GREATERP (CAAR Z) (CADR Z)) (CONS (CDR Z) (CAR Z))) (T Z)))
EXPR)
(DEFPROP UNRESOLVED
(LAMBDA NIL
(COND ((NULL POLYGON-LIST) (SETQ INTER (CONS (CONS XLOW YLOW) INTER)))
(T (SETQ UNRES (CONS (CONS XLOW YLOW) UNRES)))))
EXPR)
(DEFPROP SMALL?
(LAMBDA NIL (GREATERP 1 (DIFFERENCE XHIGH XLOW)))
EXPR)
(DEFPROP SIMPLE?
(LAMBDA NIL
(AND (GREATERP 2 (LENGTH ABOVE-LIST))
(GREATERP 2 (LENGTH SURROUNDERS-LIST))
(EQUAL ABOVE-LIST POLYGON-LIST)))
EXPR)
(DEFPROP TRIVAIL
(LAMBDA NIL (AND (NULL POLYGON-LIST) (GREATERP 2 (LENGTH SURROUNDERS-LIST))))
EXPR)
(DEFPROP CLIP
(LAMBDA NIL
(MAPC (FUNCTION
(LAMBDA(EDGE)
(PUTPROP EDGE (XXXXXX (CLIP-LINE-SEGMENT (GET EDGE (QUOTE ENDS))) (GET EDGE VIEWNAME)) VIEWNAME)))
(GET (CAR POLYGON-LIST) (QUOTE EDGES))))
EXPR)
(DEFPROP ABOVE
(LAMBDA NIL
(PROG (DEPTH-BOUND)
(SETQ DEPTH-BOUND
(LEAST
(MAPCAR (FUNCTION CAR)
(MAPCAR (FUNCTION (LAMBDA (SURROUNDER) (GET SURROUNDER (QUOTE DIW))))
SURROUNDERS-LIST))))
(SETQ ABOVE-LIST
(MAPPENDCAR (FUNCTION
(LAMBDA(POLYGON)
(COND
((LESSP (CDR (GET POLYGON (QUOTE DIW))) DEPTH-BOUND) (NCONS POLYGON))
(T NIL))))
POLYGON-LIST))))
EXPR)
(DEFPROP HIDE-POLY
(LAMBDA NIL
(PROG (DEPTH-BOUND)
(SETQ DEPTH-BOUND
(LEAST
(MAPCAR (FUNCTION CDR)
(MAPCAR (FUNCTION (LAMBDA (SURROUNDER) (GET SURROUNDER (QUOTE DIW))))
SURROUNDERS-LIST))))
(SETQ SURROUNDERS-LIST (MAPPENDCAR (FUNCTION NIL-BEYOND-DEPTH-BOUND) SURROUNDERS-LIST))
(SETQ POLYGON-LIST (MAPPENDCAR (FUNCTION NIL-BEYOND-DEPTH-BOUND) POLYGON-LIST))))
EXPR)
(DEFPROP SURROUND
(LAMBDA NIL
(SETQ POLYGON-LIST
(MAPPENDCAR (FUNCTION
(LAMBDA(POLYGON)
(COND ((SURROUNDS-WINDOW? POLYGON) (SETQ SURROUNDERS-LIST
(CONS POLYGON SURROUNDERS-LIST))
NIL)
(T (NCONS POLYGON)))))
POLYGON-LIST)))
EXPR)
(DEFPROP DIW-PROPERTY
(LAMBDA NIL
(MAPC (FUNCTION
(LAMBDA(POLYGON)
(PUTPROP POLYGON
(EXTREMA
(LIST (ZDEPTH XLOW YLOW) (ZDEPTH XHIGH YLOW) (ZDEPTH XHIGH YHIGH) (ZDEPTH XLOW YHIGH)))
(QUOTE DIW))))
(APPEND POLYGON-LIST SURROUNDERS-LIST)))
EXPR)
(DEFPROP MAPORCAR
(LAMBDA (FN L) (COND ((NULL L) NIL) ((FN (CAR L)) T) (T (MAPORCAR FN (CDR L)))))
EXPR)
(DEFPROP IS-ANY-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?
(LAMBDA NIL
(PROG (TRIANGLE-LIST)
(SPLIT-POLYGON-INTO-TRIANGLES)
(RETURN
(OR (CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XLOW YLOW)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XLOW YHIGH)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XHIGH YLOW)
(CORNER-WITHIN-ANY-TRIANGLE? TRIANGLE-LIST XHIGH YHIGH)))))
EXPR)
(DEFPROP WINDOW-IN-OPPOSITE-HALF-PLANE?
(LAMBDA(EDGE)
(PROG (SIGN EDG X Y)
(SETQ X (GET EDGE (QUOTE ENDS)))
(SETQ EDG (LIST (LIST (CAAR X) (CDAR X)) (LIST (CADR X) (CDDR X))))
(SETQ X
(DELETE (CAR (GET EDGE (QUOTE POINTS)))
(DELETE (CDR (GET EDGE (QUOTE POINTS))) (GET POLYGON (QUOTE CORNERS)))))
(SETQ X (GET (CAR X) (QUOTE IMAGE)))
(SETQ Y (CADR X))
(SETQ X (CAR X))
(SETQ SIGN (MMMM X Y EDG))
(RETURN
(AND (MINUSP (TIMES SIGN (MMMM XLOW YLOW EDG)))
(MINUSP (TIMES SIGN (MMMM XLOW YHIGH EDG)))
(MINUSP (TIMES SIGN (MMMM XHIGH YLOW EDG)))
(MINUSP (TIMES SIGN (MMMM XHIGH YHIGH EDG)))))))
EXPR)
(DEFPROP OUTSIDE
(LAMBDA NIL
(SETQ POLYGON-LIST
(MAPPENDCAR (FUNCTION
(LAMBDA(POLYGON)
(COND
((OR (GREATERP XLOW (GET POLYGON (QUOTE XHIGH)))
(GREATERP YLOW (GET POLYGON (QUOTE YHIGH)))
(LESSP XHIGH (GET POLYGON (QUOTE XLOW)))
(LESSP YHIGH (GET POLYGON (QUOTE YLOW))))
NIL)
((AND (GREATERP XHIGH (GET POLYGON (QUOTE XHIGH)))
(GREATERP YHIGH (GET POLYGON (QUOTE YHIGH)))
(LESSP XLOW (GET POLYGON (QUOTE XLOW)))
(LESSP YLOW (GET POLYGON (QUOTE YLOW))))
(NCONS POLYGON))
((IS-ANY-CORNER-OF-WINDOW-WITHIN-THE-POLYGON?) (NCONS POLYGON))
((MAPORCAR (FUNCTION WINDOW-IN-OPPOSITE-HALF-PLANE?) (GET POLYGON (QUOTE EDGES))) NIL)
(T (NCONS POLYGON)))))
POLYGON-LIST)))
EXPR)
(DEFPROP TWO-INTERSECTING-PLANES?
(LAMBDA NIL (AND (NULL POLYGON-LIST) (EQUAL 2 (LENGTH SURROUNDERS-LIST))))
EXPR)
(DEFPROP FORM-NEW-EDGE
(LAMBDA NIL
(PROG (POLY1 POLY2 EDGE)
(SETQ POLY1 (CAR SURROUNDERS-LIST))
(SETQ POLY2 (CADR SURROUNDERS-LIST))
(SETQ EDGE (SET-INTERSECTION (GET POLY1 (QUOTE EDGEZ)) (GET POLY2 (QUOTE EDGEZ))))
(SETQ POLYGON-LIST (CDR SURROUNDERS-LIST))
(COND ((NOT (NULL EDGE)) (CLIP2) (RETURN NIL)))
(SETQ EDGE (INTERN (GENSYM)))
(PUTPROP POLY1 (CONS EDGE (GET POLY1 (QUOTE EDGEZ))) (QUOTE EDGEZ))
(PUTPROP POLY2 (CONS EDGE (GET POLY2 (QUOTE EDGEZ))) (QUOTE EDGEZ))
(PUTPROP EDGE (ENDPOINTS POLY1 POLY2) (QUOTE ENDS))
(CLIP2)))
EXPR)
(DEFPROP TWO-POLY-WITH-COMMON-EDGE
(LAMBDA NIL
(AND (EQUAL 2 (LENGTH ABOVE-LIST))
(GREATERP 2 (LENGTH SURROUNDERS-LIST))
(EQUAL 2 (LENGTH POLYGON-LIST))
(EQUAL 1
(LENGTH
(SET-INTERSECTION (GET (CAR ABOVE-LIST) (QUOTE EDGES))
(GET (CADR ABOVE-LIST) (QUOTE EDGES)))))))
EXPR)
(DEFPROP ENDS-PROPERTY
(LAMBDA(POLYGON)
(MAPC (FUNCTION
(LAMBDA(EDGE)
(PROG (A B)
(SETQ A (GET EDGE (QUOTE POINTS)))
(SETQ B (GET (CAR A) (QUOTE IMAGE)))
(SETQ A (GET (CDR A) (QUOTE IMAGE)))
(PUTPROP EDGE
(CONS (CONS (PLUS (CAR B) 0.0) (PLUS (CADR B) 0.0))
(CONS (PLUS (CAR A) 0.0) (PLUS (CADR A) 0.0)))
(QUOTE ENDS))
(PUTPROP EDGE NIL VIEWNAME))))
(GET POLYGON (QUOTE EDGES))))
EXPR)
(DEFPROP INITIALIZE-CIRCUMSCRIBED-RECTANGLE-PROPERTY
(LAMBDA(POLYGON)
(PROG (XS YS)
(SETQ YS (MAPCAR (FUNCTION (LAMBDA (POINT) (GET POINT (QUOTE IMAGE)))) (GET POLYGON (QUOTE CORNERS))))
(SETQ XS (MAPCAR (FUNCTION CAR) YS))
(SETQ YS (MAPCAR (FUNCTION CADR) YS))
(PUTPROP POLYGON (LEAST XS) (QUOTE XLOW))
(PUTPROP POLYGON (LEAST YS) (QUOTE YLOW))
(PUTPROP POLYGON (MOST XS) (QUOTE XHIGH))
(PUTPROP POLYGON (MOST YS) (QUOTE YHIGH))))
EXPR)
(DEFPROP INITIALIZE-PLANE-OF-POLYGON-PROPERTIES
(LAMBDA(POLYGON)
(PROG (A B C)
(SETQ C (GET POLYGON (QUOTE CORNERS)))
(SETQ A (GET (CAR C) (QUOTE IMAGE)))
(SETQ B (GET (CADR C) (QUOTE IMAGE)))
(SETQ C (GET (CADDR C) (QUOTE IMAGE)))
(SETQ A (KRAMER A B C))
(PUTPROP POLYGON (CAR A) (QUOTE A))
(PUTPROP POLYGON (CADR A) (QUOTE B))
(PUTPROP POLYGON (CADDR A) (QUOTE C))))
EXPR)
(DEFPROP SUPERSPLICE2
(LAMBDA(POLY)
(MAPC (FUNCTION
(LAMBDA(EDGE)
(PROG (A B)
(SETQ A (MAPCAR (FUNCTION ORDLOW) (ONCEONLY (GET EDGE VIEWNAME))))
(SET B NIL)
L (COND ((NULL A) (RETURN (PUTPROP EDGE B VIEWNAME))))
(SETQ B (SPLICE2 (CAR A) B))
(SETQ A (CDR A))
(GO L))))
(APPEND (GET POLY (QUOTE EDGEZ)) (GET POLY (QUOTE EDGES)))))
EXPR)
(DEFPROP SUPERSPLICE1
(LAMBDA(POLY)
(MAPC (FUNCTION
(LAMBDA(EDGE)
(PROG (A B)
(SETQ A (MAPCAR (FUNCTION ORDLOW) (ONCEONLY (GET EDGE VIEWNAME))))
(SET B NIL)
L (COND ((NULL A) (RETURN (PUTPROP EDGE B VIEWNAME))))
(SETQ B (SPLICE1 (CAR A) B))
(SETQ A (CDR A))
(GO L))))
(APPEND (GET POLY (QUOTE EDGEZ)) (GET POLY (QUOTE EDGES)))))
EXPR)
(DEFPROP WARNOCK
(LAMBDA(ZZZZZZ XLOW XHIGH YLOW YHIGH)
(PROG (POLYGON-LIST SURROUNDERS-LIST ABOVE-LIST MX MY)
(SETQ POLYGON-LIST (CAR ZZZZZZ))
(SETQ SURROUNDERS-LIST (CDR ZZZZZZ))
(OUTSIDE)
(PRINC (QUOTE A))
(FORCE)
(DIW-PROPERTY)
(SURROUND)
(HIDE-POLY)
(ABOVE)
(COND ((TRIVAIL) NIL)
((SIMPLE?) (CLIP))
((TWO-POLY-WITH-COMMON-EDGE) (CLIP))
((TWO-INTERSECTING-PLANES?) (FORM-NEW-EDGE))
((SMALL?) (UNRESOLVED))
(T (GO L)))
(RETURN NIL)
L (SETQ MX (QUOTIENT (PLUS XLOW XHIGH) 2))
(SETQ MY (QUOTIENT (PLUS YLOW YHIGH) 2))
(WARNOCK (CONS POLYGON-LIST SURROUNDERS-LIST) MX XHIGH MY YHIGH)
(WARNOCK (CONS POLYGON-LIST SURROUNDERS-LIST) XLOW MX MY YHIGH)
(WARNOCK (CONS POLYGON-LIST SURROUNDERS-LIST) XLOW MX YLOW MY)
(WARNOCK (CONS POLYGON-LIST SURROUNDERS-LIST) MX XHIGH YLOW MY)))
EXPR)
(DEFPROP INITPOLY
(LAMBDA(POLY)
(PROG NIL
(SETQ INTER NIL)
(SETQ UNRES NIL)
(PUTPROP POLY NIL (QUOTE EDGEZ))
(INITIALIZE-PLANE-OF-POLYGON-PROPERTIES POLY)
(INITIALIZE-CIRCUMSCRIBED-RECTANGLE-PROPERTY POLY)
(ENDS-PROPERTY POLY)))
EXPR)
(DEFPROP HIDDEN-LINE
(LAMBDA(VIEWNAME POLYGON-LIST)
(PROG NIL
(MAPC (FUNCTION INITPOLY) POLYGON-LIST)
(WARNOCK (CONS POLYGON-LIST NIL) -512.0 512.0 -512.0 512.0)
(MAPC (FUNCTION SUPERSPLICE2) POLYGON-LIST)
(MAPC (FUNCTION SUPERSPLICE1) POLYGON-LIST)))
EXPR)